home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / siod / siod_v20.lha / siod.scm < prev    next >
Encoding:
Text File  |  1993-08-16  |  2.7 KB  |  123 lines
  1. '(SIOD: Scheme In One Defun -*-mode:lisp-*-
  2.  
  3. *                        COPYRIGHT (c) 1989 BY                             *
  4. *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  5. *        See the source file SLIB.C for more information.                  *
  6.  
  7.   Optional Runtime Library for Release 2.0)
  8.  
  9. (define list (lambda n n))
  10.  
  11. (define (sublis l exp)
  12.   (if (cons? exp)
  13.       (cons (sublis l (car exp))
  14.         (sublis l (cdr exp)))
  15.       (let ((cell (assq exp l)))
  16.     (if cell (cdr cell) exp))))
  17.  
  18. (define (cadr x) (car (cdr x)))
  19. (define (caddr x) (car (cdr (cdr x))))
  20. (define (cdddr x) (cdr (cdr (cdr x))))
  21.  
  22. (define (replace before after)
  23.   (set-car! before (car after))
  24.   (set-cdr! before (cdr after))
  25.   after)
  26.  
  27. (define (push-macro form)
  28.   (replace form
  29.        (list 'set! (caddr form)
  30.          (list 'cons (cadr form) (caddr form)))))
  31.  
  32. (define (pop-macro form)
  33.   (replace form
  34.        (list 'let (list (list 'tmp (cadr form)))
  35.          (list 'set! (cadr form) '(cdr tmp))
  36.          '(car tmp))))
  37.  
  38. (define push 'push-macro)
  39. (define pop 'pop-macro)
  40.  
  41. (define (defvar-macro form)
  42.   (list 'or
  43.     (list 'value-cell (list 'quote (cadr form)))
  44.     (list 'define (cadr form) (caddr form))))
  45.  
  46. (define defvar 'defvar-macro)
  47.  
  48. (define (defun-macro form)
  49.   (cons 'define
  50.     (cons (cons (cadr form) (caddr form))
  51.           (cdddr form))))
  52.  
  53. (define defun 'defun-macro)
  54.        
  55. (define setq set!)
  56. (define progn begin)
  57.  
  58. (define the-empty-stream ())
  59.  
  60. (define empty-stream? null?)
  61.  
  62. (define (*cons-stream head tail-future)
  63.   (list head () () tail-future))
  64.  
  65. (define head car)
  66.  
  67. (define (tail x)
  68.   (if (car (cdr x))
  69.       (car (cdr (cdr x)))
  70.       (let ((value ((car (cdr (cdr (cdr x)))))))
  71.     (set-car! (cdr x) t)
  72.     (set-car! (cdr (cdr x)) value))))
  73.  
  74. (define (cons-stream-macro form)
  75.   (replace form
  76.        (list '*cons-stream
  77.          (cadr form)
  78.          (list 'lambda () (caddr form)))))
  79.  
  80. (define cons-stream 'cons-stream-macro)
  81.  
  82. (define (enumerate-interval low high)
  83.   (if (> low high)
  84.       the-empty-stream
  85.       (cons-stream low (enumerate-interval (+ low 1) high))))
  86.  
  87. (define (print-stream-elements x)
  88.   (if (empty-stream? x)
  89.       ()
  90.       (begin (print (head x))
  91.          (print-stream-elements (tail x)))))
  92.  
  93. (define (sum-stream-elements x)
  94.   (define (loop acc x)
  95.     (if (empty-stream? x)
  96.     acc
  97.       (loop (+ (head x) acc) (tail x))))
  98.   (loop 0 x))
  99.  
  100. (define (standard-fib x)
  101.   (if (< x 2)
  102.       x
  103.       (+ (standard-fib (- x 1))
  104.      (standard-fib (- x 2)))))
  105.  
  106. (define (make-list n)
  107.   (define l ())
  108.   (define j 0)
  109.   (define (accumulate-list)
  110.     (if (< j n)
  111.     (begin (setq l (cons () l))
  112.            (setq j (+ j 1))
  113.            (accumulate-list))))
  114.   (accumulate-list)
  115.   l)
  116.  
  117.   
  118. (define (call-with-current-continuation fcn)
  119.   (let ((tag (cons nil nil)))
  120.     (*catch tag
  121.         (fcn (lambda (value)
  122.            (*throw tag value))))))
  123.